
#|______________________________________________________________
 |
 | containr.lsp
 |
 | Functions which interface to the MSWindows API container
 | including container and listener functions 
 | uses modifications to XLispStat written by Fabian Camacho
 | copyright (c) 2000 by Forrest Young  
 |______________________________________________________________


New Win Features by Fabian Camacho

1) (listener x y w h) positions and sizes the listener
2) (client-size) returns the size of the main client window
3) (send container-proto :new :outofclientwindow nilt :localmenu nilt) 
creates a new container window that inherits from graph-window-proto. Returns the object. All the standard arguments (size, location, show, title) can be used, plus all the graph-window features should work. Any successively created graph windows go into the container window object. Will be in the mainwindow unless OutOfClientWindow is t. Menus of contained graphs will be in the container window's menubar if :localmenu is t, in the mainwindow menubar if nil.
4) (send container-instance :getobjects t) makes container-instance the new active container. By default, it is the most recently created container-window.
5) (send container-instance :getobjects nil) makes the mainframe window the active container.
6) (send container-instance :show-window) brings it to the top
8) (send container-instance :has-v-scroll) and related scrolling msgs work.
9) (listener 0 0 350 350)
10) (mainwindow x y w h)
0804 added (mainwindow) function and return values when no arguments used
0813 added :OutOfClientWindow
0819 added :LocalMenu
0830 added
.ini file search: 1st: local .exe directory; 2nd: current-directory; 3rd: windows dir; 4th: windows/system dir; then error
(showmainwindow)
(hidemainwindow)
(effective-screen-size)
window border styles: (send container-proto :new n)
0: no border
1: thin border
2: sunken border
3,4,6: thick border
5: movable, sizable window with title and controls
7: movable window with title
8: title and and border likle standard window


11) (send graph-window-proto :pop-out t) pops out
   (send graph-window-proto :pop-out nil) pops in
   only works for windows in a container, not for free windows
12) pop-up menus: do-click m2 pops up a menu, m1 is changed to cntl
13) pop-out windows pop out in place and put-in to original size and location
14) (mainwindow) and (listener) return size/loc
15) graph-proto has a :no-move method
11/18/99
16) container-proto :new :mainwindow t
    The mainwindow t option gives window standard controls (close, max,min,etc).
    Without or mainwindow nil has no controls (max,min by douple-click on title bar)
17) window-proto object now have a :top-most method, but only when pop-out is t. Note that :top-most incorrectly returns nil when it has been set to t (in other words, it always returns nil)
18) all dialog are top-most
19) :putincontainer can be an option of :new that makes a new container nested inside the active container. nested arbitrarily deep.
11/23/99
20) Window Title bars work right
21) -verbose -showmainwindow on command line
22) dialogs are topmost
23) top-most can be deactivated with top-most nil
24) (send window-proto :bottom-most nilt)

 |______________________________________________________________
 |#

(defun container (&key (in nil set) (style 5) (enabled t)
                        (toolwindow nil) (localmenu nil)
                        (size '(250 250)) (location '(54 24))
                        (title "Container Window") (show t) 
                        (menu nil) (black-on-white t) 
                        (has-v-scroll nil) (has-h-scroll nil)
                        )
 "Keyword Args: (in nil set) (style 5) (enabled t) (toolwindow nil) (localmenu nil) (size '(250 250)) (location '(54 24)) (title \"Container Window\") (show t) (has-v-scroll nil) (has-h-scroll nil) (menu nil) (black-on-white t)
  Creates a new container window that inherits from graph-window-proto. Returns the container object in ENABLED state (T by default). All the standard arguments (size, location, show, title, menu, has-v-scroll, has-h-scroll, black-on-white) can be used, plus all the graph-window features should work. 
  The new container window can be inside the main client window, inside another container window, or outside of all other windows. Where it goes depends on the value of :IN. The new container goes:
1) inside the main xlispstat client window if :IN is not specified (the default)
2) inside CONTAINER-OBJECT when :IN CONTAINER-OBJECT is specified. An error is signaled if CONTAINER-OBJECT does not exist or is not a container object.
3) on the desktop (i.e., inside no other window) when :IN NIL is specified. Desktop containers have the standard controls (close, max, min, restore, etc) unless TOOLWINDOW is T.
4) inside the currently enabled container window when :IN T is specified (or in the XLispStat client window if no container window is enabled).
  The newly created container window becomes the enabled window, and *active-container* is bound to the new container object. Any successively created graph windows (or window protos with graph-window as an ancestor) go into the new container object until another container object is enabled. If no container object is enabled new graph windows go into the main client window.  
  Menus of contained graph windows will be in the container window's menubar if LOCALMENU is t, in the mainwindow if LOCALMENU is nil.
   When inside a container, the contained windows will have borders and title bar style determined by STYLE, an integer, as follows: 0 = no border; 1 = thin border; 2 = sunken border; 3, 4, and 6 = thick border; 5 = standard window (default - a movable, sizable window with title and controls); 7 = movable window with title; and 8 = standard window border and title - no titles for 0-4, title 5-8"
  (let* ((results (new-to-old-container-arguments in set))
         (in-client (first results))
         (in-container (second results))
         (container-instance (third results))
         )
    (setf *active-container*
          (send container-proto :new style
                :outofclientwindow (not in-client) :putincontainer in-container
                :localmenu localmenu :mainwindow (not toolwindow)
                :size size :location location 
                :title title :show show 
                :menu menu :black-on-white black-on-white
                :has-v-scroll has-v-scroll :has-h-scroll has-h-scroll
                ))
    (send *active-container* :style style)
    (send *active-container* :add-slots-and-features)
    (when enabled (enable-container *active-container*))
    *active-container*)
  )

(defun container-window (&rest args)
  (apply #'make-container args))

(defun make-container (&key (type 0) (size '(250 250)) (location '(54 24))
                            (title "Container Window") (show t) (enabled t)
                            (menu nil) (black-on-white t) (putincontainer nil)
                            (has-v-scroll nil) (has-h-scroll nil)
                            (free nil) (mainwindow t)
                            (local-menus nil)
                            )
  "Keyword Args: (type 0)  (putincontainer nil) (free nil) (mainwindow t) (local-menus nil) (size '(250 250)) (location '(54 24)) (title \"Container Window\") (show t) (has-v-scroll nil) (has-h-scroll nil) (menu nil) (black-on-white t)
  Creates a new container window that inherits from graph-window-proto. Returns the container object. All the standard arguments (size, location, show, title, menu, has-v-scroll, has-h-scroll, black-on-white) can be used, plus all the graph-window features should work. 
  The new container window can be inside the main client window, inside another container window, or outside of all other windows. Where it goes depends on the values of FREE and PUTINCONTAINER and on whether another container window is enabled. The new container goes:
1: inside the main xlispstat client window when 
   (make-container :free nil :putincontainer nil) 
   regardless of whether there is an enabled 
   container. This is the default.
2: inside the main xlispstat client window when 
   (make-container :free nil putincontainer t) 
   but when no container is enabled.
3: inside the currently enabled container window when 
   (make-container :free nil putincontainer t) 
   and a container is enabled.
4: on the desktop (i.e., inside no other window) when 
   (make-container :free t :putincontainer nil) 
   regardless of whether a container is enabled.
  The newly created container window becomes the enabled window, and *active-container* is bound to the new container object. Any successively created graph windows (or window protos with graph-window as an ancestor) go into the new container object until another container object is enabled. If no container object is enabled new graph windows go into the main client window.
  The container window has standard controls (close, max, min, etc) if MAINWINDOW is T, no controls if NIL.  
  Menus of contained graph windows will be in the container window's menubar if LOCALMENU is t, in the mainwindow if LOCALMENU is nil.
  The contained graph windows will have borders and title bar appearance determined by TYPE, as follows:
TYPE=0: no border 
TYPE=1: thin border
TYPE=2: sunken border
TYPE=3,4,6: thick border
TYPE=5: standard window (movable, sizable window with title and controls) (default)
TYPE=7: movable window with title
TYPE=8: standard window border and title
"
   (setf *active-container*
         (send container-proto :new type
               :size size :location location :mainwindow mainwindow
               :title title :show show
               :menu menu :black-on-white black-on-white
               :has-v-scroll has-v-scroll :has-h-scroll has-h-scroll
               :outofclientwindow free :putincontainer putincontainer
               :localmenu local-menus))
   (send *active-container* :style type)
   (send *active-container* :add-slots-and-features)
   (when enabled (enable-container *active-container*))
   *active-container*) 

(defmeth container-proto :style (&optional (type nil set))
  (unless (send self :has-slot 'style)
          (send self :add-slot 'style))
  (if set (setf (slot-value 'style) type))
  (slot-value 'style))

(defmeth container-proto :n-graphs (&optional (count nil set))
  (unless (send self :has-slot 'n-graphs)
          (send self :add-slot 'n-graphs))
  (if set (setf (slot-value 'n-graphs) count))
  (slot-value 'n-graphs))
 
(setf *active-container* nil)

#|_______________________
 |
 | Four methods (:show-window :hide-window :remove :showing)
 | Added by fwy 03172001. should be inherited but are not
 |_______________________
 |#


(defmeth container-proto :showing (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether the window is showing."
  (unless (send self :has-slot 'showing)
          (send self :add-slot 'showing))
  (if set (setf (slot-value 'showing) logical))
  (slot-value 'showing))

(defmeth container-proto :show-window ()
  (call-next-method)
  (if (send self :has-slot 'showing)
      (send self :showing t)
      (send self :add-slot 'showing t)))

(defmeth container-proto :hide-window ()
  (call-next-method)
  (if (send self :has-slot 'showing)
      (send self :showing nil)
      (send self :add-slot 'showing nil)))

(defmeth container-proto :remove ()
  (call-next-method)
  (if (send self :has-slot 'showing)
      (send self :showing nil)
      (send self :add-slot 'showing nil)))

#| code in runtime/graphic0.lsp

;fwy added dec 2002
(defmeth container-proto :active-window ()
"Args: none
Activates window without changing top-bottom position"
  (send self :always-on-top (send self :always-on-top))
  (send self :bottom-most (send self :bottom-most))
  t)


;fwy changed from this
;(defmeth graph-window-proto :front-window ()
;  (send self :show-window)
;  (send self :top-most t)
;  (send self :top-most nil))

;to this
(defmeth graph-window-proto :front-window ()
  (send self :show-window)
  (when (not (send self :top-most))
        (send self :top-most t)
        (send self :top-most nil))
  (send self :top-most))

;to this (dec 2002)
(defmeth graph-window-proto :front-window ()
"Args: none
makes window the front-window. returns t"
  (send self :show-window)
  (let ((in-top (send self :top-most)))
    (send self :top-most t)
    (when (not in-top)
          (send self :top-most nil))
    t))
|#


#| TOP-MOST METHODS |#

;NOTE THAT (SEND * :TOP-MOST) ALWAYS REPORTS NIL REGARDLESS OF STATE,
;BUT THAT  (SEND * :TOP-MOST T) AND (SEND * :TOP-MOST NIL) SET AND REPORT CORRECTLY
;SO HAVE ADDED SLOT TOP-MOST-STATE TO KEEP TRACK OF STATE

(defmeth container-proto :top-most-state (&optional (logical nil set))
"Args: (&optional logical)
Slot for top-most method (which does not have a slot) that correctly remembers top-most state. Note that (send * :top-most) always reports that top-most is NIL regardless of actual state, but that (send * :top-most t) and (send * :top-most nil) set and report the correctly."
  (unless (send self :has-slot 'top-most-state)
          (send self :add-slot 'top-most-state))
  (if set (setf (slot-value 'top-most-state) logical))
  (slot-value 'top-most-state))
  
(defmeth container-proto :always-on-top (&optional (logical nil set))
"Args: (&optional logical)
Sets and reports top-most state correctly. Note that (send * :top-most) always reports that top-most is NIL regardless of actual state, but that (send * :top-most t) and (send * :top-most nil) set and report the correctly."
  (unless (send self :has-slot 'top-most-state)
          (send self :add-slot 'top-most-state))
  (if set (setf (slot-value 'top-most-state) logical))
  (cond 
    (set 
      (send self :top-most logical)
      (send self :redraw))
    (t
      (send self :top-most-state)))
  )

  (defmeth container-proto :seen-in (in in?)
    "Args IN IN?
Determines where windows will be seen and returns value indicating where this is. IN can be T, NIL, or a container window object. IN? can be T or NIL. Will be seen on the Desktop if IN? is NIL or if none of the following conditions hold: Will be seen in IN if IN is a container object; in *ACTIVE-CONTAINER* if IN is T and there is an active container; or in the XLISPSTAT window if IN is NIL. Returns T, NIL or IN, meaning the window will appear on the DESKTOP, in XLISPSTAT or in CONTAINER, respective"
    (cond 
      ((not in?)    (enable-container self)   t)   ;desktop
      ((not in)     (disable-container)      nil)  ;xlispstat
      ((objectp in) (enable-container in)     in)  ;IN
      ((and (equal t in) 
            (objectp *active-container*))    *active-container*) ;*active-container*
      (t            (enable-container self)   t)   ;desktop
      ))



(defmeth container-proto :close ()
  (call-next-method)
  (if (equal self *active-container*)
      (setf *active-container* nil)))


(defmeth container-proto :enabled (&optional (logical nil set))
"Message args: (&optional list)
Sets or retrieves whether the container is enabled (ready to getobjects) and binds *active-container* to slot value."
  (when set (send self :getobjects logical)
        (when (and logical *active-container*)
              (when (not (equal *active-container* self))
                    (send *active-container* :enabled nil)))
        (setf *active-container* (if logical self nil))
       ; (when *container-verbose* 
       ;       (format t "; active container: ~a~%" *active-container*)
       ;       (if *active-container* 
       ;           (format t "; container title:  ~a~%" (send *active-container* :title))))
        )
  (send self :getobjects))

(defmeth container-proto :enabled (&optional (logical nil set))
"Message args: (&optional (logical nil set))
If there is an argument:
   Enable or disable self acording to ARG.
   Disable *active-container*, if there is one 
   Set *active-container* to SELF or NIL, acording to ARG.
Report whether SELF is enabled."
  (when set (send self :getobjects logical)
        (when *active-container* 
              (send *active-container* :getobjects nil))
        (setf *active-container* (if logical self nil))
        (when *container-verbose* 
              (format t "Active container: ~a " *active-container* )
              (if *active-container*
                  (format t "title: ~a" (send *active-container* :title))
                  (format t "~%")))
        )
  (send self :getobjects))

(defun new-to-old-container-arguments (in set)
  (let ((in-client)
         (in-container)
         (container-instance)
         )
     (cond 
       ((not set)
        ;if not specified container goes in client
        (setf in-client t)
        (setf in-container nil)
        (disable-container)) 
       ((not in) 
        ;if nil specified nil, container goes on desktop
        (setf in-client nil)
        (setf in-container nil)
        (disable-container))  
       ((objectp in) 
        ;if container specified, new container goes in old container
        (setf in-client t)
        (setf in-container t)
        (enable-container in)) 
       ((equal t in)
        ;if t specified, new container goes in enabled container, client if none
        (setf in-client *active-container*)
        (setf in-container (not (not *active-container*)))
        )                  
       (t (error-dialog "Incorrect container specification")))
    (list in-client in-container container-instance)))

#|______________________________________________________________
 |
 | container-window   
 |______________________________________________________________
 |#


(defmeth container-proto :add-slots-and-features ()
  (send self :use-color t)
  (send self :add-slot 'restore-sizeloc 
        (list (floor (* 3/4 (effective-screen-size))) '(0 0)))
  (defmeth self :restore-sizeloc (&optional (list nil set))
    (if set (setf (slot-value 'restore-sizeloc) list))
    (slot-value 'restore-sizeloc)))
 
(defun enable-container (c-obj)
  (cond 
    ((not c-obj) (disable-container))
    ((not (objectp c-obj)) (error "not an object"))
    (t
     (when *active-container*
           (send *active-container* :enabled nil))
     (when c-obj (send c-obj :enabled t))
     (setf *active-container* c-obj)))
  *active-container*)
 
 
(defun disable-container ()
  (when *active-container*
        (send *active-container* :enabled nil)
        ;previous statment may change *active-container* to nil
        (when *active-container* 
              (send *active-container* :getobjects nil)
              (setf *active-container* nil)))
  *active-container*)


(defmeth container-proto :restore ()
  (apply #'send self :frame-size (first (send self :restore-sizeloc)))
  (apply #'send self :frame-location (second (send self :restore-sizeloc)))
  )

(defmeth container-proto :maximize ()
  (send self :restore-sizeloc (list (send self :frame-size) (send self :frame-location)))
  (send self :frame-location -4 -4)
  (apply #'send self :frame-size (+ '(8 8) (effective-screen-size))))

(defmeth container-proto :size (&optional (w nil used-w!) (h nil used-h!))
"Args: w h
Works same as usual :size method, except modified to recognize presence of MS-Windows toolbars attached to sides of the screen. Could be used as is for graph-proto"
  (let* ((new-wh (if (or used-h! used-w!) 
                     (call-next-method w h) (call-next-method)))
         (w (first new-wh))
         (h (second new-wh))
         (max-wh (effective-screen-size))
         (max-w (first max-wh))
         (max-h (- (second max-wh) 20))
         )
    (if (> w max-w) (setf w max-w))
    (if (> h max-h) (setf h max-h))
    (list w h)))


(defun hide-vista ()
  (hidemainwindow)
  (setf *hide-vista* t)
  (when (and (boundp '*logo-container*) *logo-container*)
        (send *logo-container* :hide-window)
        (when (and (boundp '*desktop-container*) *desktop-container*) 
              (send *desktop-container* :hide-window)
              (save-desktop-settings)))
  t)

(defun showmainlistener ()
  (let ((sizeloc (mainwindow)))
    (hidemainwindow)
    (listener 4 24 (- (third sizeloc) 4)
              (floor (* 3/4 (fourth sizeloc))))
    (apply #'mainwindow sizeloc)
    (showmainwindow)))

(defun make-desktop-container-size-methods ()
  (send *vista* :make-desktop-container-resize)
  )

(defmeth container-proto :make-desktop-container-size () )


(defmeth container-proto :make-desktop-container-default-layout ()
  (let* ((dif (- (send self :location) 
                 (send self :frame-location))))
    (setf *frame-pixels* (first dif))
    (setf *title-pixels* (- (second dif) *frame-pixels*))
    (send *vista* :desktop-location 
          (+ ' (15 15) 
             (list *frame-pixels* (+ *frame-pixels* *title-pixels*))))
    (send *vista* :desktop-size 
          (- (screen-size) '(30 30) dif (repeat *frame-pixels* 2)))
    (send *vista* :workmap-proportion .6)
    (send *vista* :spreadplot-sizes (screen-size))
    (seven-desktop-values)))         

#|REPLACED BY FOLLOWING METHOD - FWY 2001-0326
(defmeth container-proto :make-desktop-container-resize ()
  (let* ((container self))
    (send container :idle-on nil)
    (defmeth container :resize ()
      (send container :resize-the-desktop)
      (send *vista* :desktop-size (send self :size))
      (setf *desktop-loc-size* (set-desktop-loc-size))
      )
    (defmeth container :location (&optional (x nil setx) (y nil sety))
      (let ((xy (if setx (call-next-method x y) (call-next-method))))
        (send *vista* :desktop-location xy)
        (setf *desktop-loc-size* (combine xy (send self :size)))
	xy))
    (defmeth container :resize-the-desktop ()
      (cond
        ((send container :idle-on) )
        (t 
         (send *workmap* :back-color 'white)
         (send *var-window* :back-color 'white)
         (send *obs-window* :back-color 'white)
         (defmeth (send *varobs-obj* :fake-overlay) :redraw ())
         (defmeth *workmap* :redraw ())
         (defmeth *desktop-datasheet* :redraw ())
         (defmeth *varobs-obj* :redraw ())
         (when *listener* (send *listener* :location 2000 2000))
         (send container :idle-on t))))
    (defmeth container :do-idle ()
      (send container :idle-on nil)                                            
      (send *var-window* :back-color 'workmap-background)
      (send *obs-window* :back-color 'workmap-background)
      (defmeth (send *varobs-obj* :fake-overlay) :redraw ()(call-next-method))
      (defmeth *desktop-datasheet* :redraw ()(call-next-method))
      (defmeth *varobs-obj* :redraw ()(call-next-method))
      (send *vista* :resize)
      (save-gui)
      )
    )) 
|#

(setf *desktop-sheet* nil)


(defmeth container-proto :make-desktop-container-resize ()
  (enable-container self)
  (let* ((container self))
       
    (unless *desktop-sheet* 
            (setf *desktop-sheet* (send graph-window-proto :new  
                                :location '(2000 2000) :size '(2000 2000)))
            )

    (send container :idle-on nil)

    (defmeth container :resize ()
      (send container :resize-the-desktop)
      (send *vista* :desktop-size (if *full-screen* 
                                      (+ '(0 20) (send self :size))
                                      (list (maximum 560 (first (send self :size)))
                                            (maximum 300 (second (send self :size))))))

      (setf *desktop-loc-size* (set-desktop-loc-size))
      )

    (defmeth container :location (&optional (x nil setx) (y nil sety))
      (let ((xy (if setx (call-next-method x y) (call-next-method))))
        (send *vista* :desktop-location xy)
        (setf *desktop-loc-size* (combine xy (send self :size)))
	xy))

    (defmeth container :resize-the-desktop ()
      (cond
        ((send container :idle-on) )
        (t 
         (send *desktop-sheet* :top-most t)
         (send *desktop-sheet* :bottom-most nil)
         (send *desktop-sheet* :location 0 0)
         (mapcar #'(lambda (w)
                     (send w :top-most nil)
                     (send w :bottom-most t))
                 (list *workmap* *varobs-obj*))
        
        ; (send *varobs-obj* :bottom-most t)
         (when *listener* (send *listener* :location 2000 2000))
        ; (send *workmap* :bottom-most t)
	;(when *current-datasheet*
        ;   (send *current-datasheet* :bottom-most t)
        ;   (send *current-datasheet* :top-most nil))
         (send container :idle-on t))))
    
    (defmeth container :do-idle ()
      (send container :idle-on nil)
      (when *startup-verbose* (format t "; CONTAIN1.LSP: CONTAINER DO IDLE"))
      (defmeth (send *varobs-obj* :fake-overlay) :redraw ()(call-next-method))
      (defmeth *workmap* :redraw ()(call-next-method))
     ; (defmeth *desktop-datasheet* :redraw ()(call-next-method))
      (defmeth *varobs-obj* :redraw ()(call-next-method))
     ; (send *varobs-obj* :top-most t)
      (send *vista* :resize)
      (mapcar #'(lambda (w)
                  (send w :top-most t)
                  (send w :bottom-most nil))
              (list  *varobs-obj* *workmap* ))
     ;(when *current-datasheet*
     ;   (send *current-datasheet* :bottom-most t)
     ;   (send *current-datasheet* :top-most nil))
      (send *desktop-sheet* :location 2000 2000)
      (send *desktop-sheet* :top-most nil)
      (send *desktop-sheet* :bottom-most t)
      ;(save-gui)
      ;(send *vista* :resize)
      )
    ))


(defmeth container-proto :make-desktop-container-resize-for-maximized-listener ()
  (send *listener* :frame-location 0 0)
  (defmeth *listener* :resize ()
    (apply #'send self :size 
         (- (send *desktop-container* :size) '( 8 46))))
  (defmeth *desktop-container* :resize ()
    (call-next-method)
    (send *listener* :resize))
  (send *listener* :resize)
  )

(defmeth container-proto :make-desktop-container-resize-for-popped-out-listener ()
  (send self :make-desktop-container-resize))


(defmeth container-proto :make-close-menu (&optional items)
  (send self :add-slot 'close-menu)
  (defmeth self :close-menu (&optional (objid nil set))
    (if set (setf (slot-value 'close-menu) objid))
    (slot-value 'close-menu))
  (let* ((menu (send menu-proto :new "Close PopUp"))
         (window self)
         (items (if items items
                    (list (send menu-item-proto :new "Close (Discard)"
                                :action #'(lambda () (send window :remove)))
                          (send menu-item-proto :new "Minimize (Save for Later)"
                                :action #'(lambda () (send window :hide-window)))
                          (send dash-item-proto :new)
                          (send menu-item-proto :new "Exit (Quit ViSta Session)" 
                                :action #'vista-exit)))))
    (apply #'send menu :append-items items)
    (defmeth self :close ()
      (send (send self :close-menu)
            :popup (- (first (send self :size)) 20) -20 self))
    (send self :close-menu menu)
    (send menu :install)
    menu))

